home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.004 / xemacs-1 / xemacs-19.13 / lisp / energize / backtrace-logging.el next >
Encoding:
Text File  |  1994-09-20  |  4.7 KB  |  179 lines
  1. ;;; -*- Mode: EMACS-LISP; Syntax: E-Lisp; Base: 10 -*-
  2. ;;;
  3. ;;;; backtrace-logging.el
  4. ;;;
  5. ;;; User code for interacting with backtrace logging.
  6. ;;;
  7. ;;; ***************************************************************************
  8. ;;;
  9. ;;; Revision:    29-Jan-92 12:14:49
  10. ;;;
  11. ;;; Programmer: Harlan Sexton
  12. ;;;
  13. ;;; Edit-History:
  14. ;;;
  15. ;;; Created: 30-Aug-91 by hbs
  16. ;;;
  17. ;;; End-of-Edit-History
  18.  
  19. (defvar *btl-index-counter* 1)
  20. (defvar *btl-data-file* nil)
  21. (defvar *btl-indices-assigned* nil)
  22. (defvar elisp-only-btl nil)
  23. (defvar cadillac-id-tag-save 'cadillac-id-tag-save)
  24.  
  25. (defun assign-btl-indices (&optional force)
  26.   (if (or force 
  27.       (not *btl-indices-assigned*))
  28.       (progn
  29.     (mapatoms 'assign-btl-index)
  30.     (setq *btl-indices-assigned* t))))
  31.  
  32. (defun btl-compiled-p (function)
  33.   (or (subrp function)
  34.       (compiled-function-p function)
  35.       (and (consp function)
  36.        (eq (car function) 'lambda)
  37.        (let ((rest (cdr (cdr function)))
  38.          (quit nil))
  39.          (while (and rest (not quit)) 
  40.            (let ((trial (car rest)))
  41.          (if (consp trial)
  42.              (setq quit (eq (car trial) 'byte-code)))
  43.          (setq rest (cdr rest))))
  44.          quit))))
  45.  
  46. (defun get-btl-index (symbol)
  47.   (if (symbolp symbol)
  48.       (let ((val (or (get symbol cadillac-id-tag)
  49.              (get symbol 'cadillac-id-tag-save))))
  50.     (if (and val (integerp val) (> val 0))
  51.         val
  52.       (progn
  53.         (setq val *btl-index-counter*)
  54.         (setq *btl-index-counter* (1+ *btl-index-counter*))
  55.         val)))))
  56.       
  57. (defun disable-btl-index (symbol)
  58.   (if (symbolp symbol)
  59.       (let ((val (or (get symbol cadillac-id-tag)
  60.              (get symbol 'cadillac-id-tag-save))))
  61.     (if (and val (integerp val) (> val 0))
  62.         (put symbol 'cadillac-id-tag-save val))
  63.     (remprop symbol cadillac-id-tag))))
  64.  
  65. (defun assign-btl-index (symbol)
  66.   (if (and (symbolp symbol)
  67.        (fboundp symbol))
  68.       (let* ((function (symbol-function symbol))
  69.          (subr-function (subrp function))
  70.          (compiled-function (btl-compiled-p function))
  71.          (tagged-function (get symbol cadillac-id-tag)))
  72.     (cond ((and elisp-only-btl compiled-function (not tagged-function))
  73.            (put symbol cadillac-id-tag (get-btl-index symbol)))
  74.           ((and (not elisp-only-btl) subr-function tagged-function)
  75.            (disable-btl-index symbol))))))
  76.                     
  77. (defun file-to-btl-data-file (file)
  78.   (let ((base-dir (expand-file-name "")))
  79.     (if (string-equal base-dir file)
  80.     (setq file nil)))
  81.   (setq file (or file *btl-data-file*))
  82.   (let ((go-ahead nil))
  83.     (if (or (not (stringp file))
  84.         (file-directory-p file))
  85.     (setq go-ahead nil)
  86.       (if (file-exists-p file)
  87.       (setq go-ahead
  88.         (y-or-n-p (message "File exists -- overwrite %s? "
  89.                    file)))
  90.     (setq go-ahead t)))
  91.     (if (not go-ahead)
  92.     (error "Bad data file.")))
  93.   file)
  94.  
  95. (defun btl-init (file &optional pc-logging)
  96.   (setq file (file-to-btl-data-file file))
  97.   (let ((log-type (if pc-logging "PC logging" "btl")))
  98.     (message (format "Initializing %s..." log-type))
  99.     (sit-for 0)
  100.     (assign-btl-indices t)
  101.     (setq *btl-data-file* file)
  102.     (if pc-logging
  103.     (initialize-pc-logging-internal file)
  104.       (initialize-backtrace-logging-internal file))
  105.     (message (format "Initializing %s...done." log-type))       
  106.     (sit-for 1)
  107.     (message "")        
  108.     (sit-for 0)))
  109.  
  110. (defun start-btl (file &optional elisp-flag-val)
  111.   (interactive "FFile in which to write data: ")
  112.   (terminate-logging)
  113.   (setq elisp-only-btl elisp-flag-val)
  114.   (btl-init file)
  115.   (start-logging))
  116.  
  117. (defun start-btl-elisp (file)
  118.   (interactive "FFile in which to write data: ")
  119.   (start-btl file t))
  120.  
  121. (defun consing-btl (file &optional elisp-flag-val)
  122.   (interactive "FFile in which to write data: ")
  123.   (terminate-logging)
  124.   (setq elisp-only-btl elisp-flag-val)
  125.   (set-log-signal 0)
  126.   (btl-init file)
  127.   (start-logging))
  128.  
  129. (defun consing-btl-elisp (file)
  130.   (interactive "FFile in which to write data: ")
  131.   (consing-btl file t))
  132.  
  133. (defun set-elisp-btl (arg)
  134.   (interactive "p")
  135.   (setq elisp-only-btl (eql arg 1)))
  136.  
  137. (defun start-pcl (file &optional elisp-flag-val)
  138.   (interactive "FFile in which to write data: ")
  139.   (setq elisp-only-btl elisp-flag-val)
  140.   (btl-init file t)
  141.   (start-logging))
  142.  
  143. (defun start-pcl-elisp (file)
  144.   (interactive "FFile in which to write data: ")
  145.   (start-pcl file t))
  146.  
  147. (defun suspend-btl ()
  148.   (interactive)
  149.   (stop-logging))
  150.  
  151. (defun suspend-pcl ()
  152.   (interactive)
  153.   (stop-logging))
  154.  
  155. (defun resume-btl ()
  156.   (interactive)
  157.   (start-logging))
  158.  
  159. (defun resume-pcl ()
  160.   (interactive)
  161.   (start-logging))
  162.  
  163. (defun stop-btl ()
  164.   (interactive)
  165.   (terminate-logging))
  166.  
  167. (defun stop-pcl ()
  168.   (interactive)
  169.   (terminate-logging))
  170.  
  171. (defun show-btl ()
  172.   (interactive)
  173.   (terminate-logging)
  174.   (switch-to-buffer (get-buffer-create "*BTL Log Info*"))
  175.   (goto-char (point-max))
  176.   (buffer-disable-undo (current-buffer))
  177.   (if *btl-data-file*
  178.       (summarize-logging *btl-data-file*)))
  179.